home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / cl-support / cl-definitions.lisp next >
Encoding:
Text File  |  1994-09-27  |  50.7 KB  |  207 lines  |  [TEXT/CCL2]
  1. se are keywords for pprint-indent
  2.  
  3. ;; (define-mumble-import mumble::block)  ; already imported as special form
  4. (define-mumble-import mumble::current)
  5.  
  6. ;;; These are keywords for pprint-tab
  7.  
  8. (define-mumble-import mumble::line)
  9. (define-mumble-import mumble::section)
  10. (define-mumble-import mumble::line-relative)
  11. (define-mumble-import mumble::section-relative)
  12.  
  13.  
  14. ;;;=====================================================================
  15. ;;; System Interface
  16. ;;;=====================================================================
  17.  
  18. (define-mumble-import macroexpand-1)
  19. (define-mumble-import macroexpand)
  20.  
  21.  
  22. ;;; This is a real kludge.  Some lisps have renamed special-form-p
  23. ;;; as per ANSI, others have not.  Rather than trying to guess which
  24. ;;; Lisp is which, just test to see if it's there.
  25.  
  26. (defmacro maybe-special-form-p (x)
  27.   (if (fboundp 'special-form-p)
  28.       `(special-form-p ,x)
  29.       `(special-operator-p ,x)))
  30.  
  31. (define-mumble-function mumble::syntax? (x)
  32.   (or (macro-function x)
  33.       (maybe-special-form-p x)))
  34.  
  35. (define-mumble-synonym mumble::bound? boundp)
  36. (define-mumble-synonym mumble::fbound? fboundp)
  37.  
  38.  
  39. ;;; WITH-COMPILATION-UNIT is an ANSI CL feature that isn't yet
  40. ;;; supported by all Lisps.
  41.  
  42. #+lucid
  43. (define-mumble-macro mumble::with-compilation-unit (options &body body)
  44.   (declare (ignore options))
  45.   `(lcl:with-deferred-warnings ,@body))
  46.  
  47. #+(or cmu mcl allegro lispworks)
  48. (define-mumble-import with-compilation-unit)
  49.  
  50. #+(or akcl wcl clisp)
  51. (define-mumble-macro mumble::with-compilation-unit (options &body body)
  52.   (declare (ignore options))
  53.   `(progn ,@body))
  54.  
  55. #-(or lucid allegro cmu akcl mcl lispworks wcl clisp)
  56. (missing-mumble-definition mumble::with-compilation-unit)
  57.  
  58.  
  59. (define-mumble-function mumble::eval (form &optional compile-p)
  60.   (if compile-p
  61.       #+cmu
  62.       (handler-bind
  63.         ((style-warning #'(lambda (c) (muffle-warning c))))
  64.         (mumble::with-compilation-unit ()
  65.           (eval-compiling-functions form)))
  66.       #-cmu
  67.       (mumble::with-compilation-unit ()
  68.         (eval-compiling-functions form))
  69.       (eval form)))
  70.  
  71.  
  72. ;;; Simply doing (funcall (compile nil `(lambda () ,form))) would work
  73. ;;; except that top-level-ness actions would be lost (causing extraneous
  74. ;;; warning messages about global variables whose references are compiled
  75. ;;; before a previous predefine is executed, etc).  So make an attempt
  76. ;;; to process nested top-level forms in order.  This doesn't look for
  77. ;;; all of the common-lispy things that might show up in macro expansions,
  78. ;;; but it's close enough.
  79.  
  80. (defun eval-compiling-functions (form)
  81.   (if (atom form)
  82.       (eval form)
  83.       (let ((fn  (car form)))
  84.     (cond ((or (eq fn 'mumble::begin)
  85.            (eq fn 'progn))
  86.            (do ((forms (cdr form) (cdr forms)))
  87.            ((null (cdr forms)) (eval-compiling-functions (car forms)))
  88.            (eval-compiling-functions (car forms))))
  89.           ((eq fn 'mumble::define)
  90.            (if (consp (cadr form))
  91.            (compile-define form)
  92.            (compile-other form)))
  93.           ((eq fn 'mumble::define-integrable)
  94.            (if (consp (cadr form))
  95.            (progn
  96.              (proclaim `(inline ,(car (cadr form))))
  97.              (compile-define form))
  98.            (compile-other form)))
  99.           ((eq fn 'mumble::predefine)
  100.            (do-predefine (cadr form)))
  101.           ((macro-function fn)
  102.            (eval-compiling-functions (macroexpand-1 form)))
  103.           (t
  104.            (compile-other form))))))
  105.  
  106. (defun compile-define (form)
  107.   (let ((name  (car (cadr form)))
  108.     (args  (mung-lambda-list (cdr (cadr form))))
  109.     (body  (cddr form)))
  110.     (compile name `(lambda ,args ,@body))
  111.     name))
  112.  
  113. (defun compile-other (form)
  114.   (funcall (compile nil `(lambda () ,form))))
  115.  
  116.  
  117. ;;; Load and compile-file aren't directly imported from the host
  118. ;;; Common Lisp because we want to do our own defaulting of file
  119. ;;; name extensions.
  120.  
  121. (define-mumble-function mumble::load (filename)
  122.   (setq filename (expand-filename filename))
  123.   (if (string= (mumble::filename-type filename) "")
  124.       (let ((source-file  (build-source-filename filename))
  125.         (binary-file  (build-binary-filename filename)))
  126.     (if (and (probe-file binary-file)
  127.          (> (file-write-date binary===============================================================
  128.  
  129.  
  130. ;;; Make the default readtable recognize #f and #t.
  131. ;;; CMUCL's loader rebinds *readtable* when loading file, so can't
  132. ;;; setq it here; hack the default readtable instead.
  133.  
  134. #+(or cmu mcl allegro lispworks clisp)
  135. (defparameter *mumble-readtable* *readtable*)
  136.  
  137. #+(or lucid akcl wcl)
  138. (progn
  139.   (defparameter *mumble-readtable* (copy-readtable nil))
  140.   (setq *readtable* *mumble-readtable*)
  141.   )
  142.  
  143. #-(or lucid allegro cmu akcl mcl lispworks wcl clisp)
  144. (missing-mumble-definition *mumble-readtable*)
  145.  
  146.  
  147. ;;; Lucid's debugger uses the standard readtable rather than *readtable*
  148. ;;; unless you do this magic trick.
  149.  
  150. #+lucid
  151. (sys:add-debugger-binding '*readtable* *mumble-readtable*)
  152.  
  153.  
  154.  
  155. (set-dispatch-macro-character #\# #\f
  156.     #'(lambda (stream subchar arg)
  157.     (declare (ignore stream subchar arg))
  158.     nil))
  159.  
  160. (set-dispatch-macro-character #\# #\t
  161.     #'(lambda (stream subchar arg)
  162.     (declare (ignore stream subchar arg))
  163.     t))
  164.  
  165.  
  166.  
  167. ;;;=====================================================================
  168. ;;; Random stuff
  169. ;;;=====================================================================
  170.  
  171. (defconstant mumble::lisp-implementation-name *lisp-implementation-name*)
  172. (define-mumble-import mumble::lisp-implementation-name)
  173.  
  174. (define-mumble-function mumble::identify-system ()
  175.   (format nil "~a version ~a on ~a"
  176.       (or (lisp-implementation-type)
  177.           "Generic Common Lisp")
  178.       (or (lisp-implementation-version)
  179.           "Generic")
  180.       (or (machine-type)
  181.           "Generic Machine")))
  182.  
  183. (defconstant mumble::left-to-right-evaluation t)
  184. (define-mumble-import mumble::left-to-right-evaluation)
  185.  
  186.  
  187. #+excl
  188. (define-mumble-function mumble::gc-messages (onoff)
  189.   (setf (sys:gsgc-switch :print) onoff))
  190. #+cmu
  191. (define-mumble-function mumble::gc-messages (onoff)
  192.   (setf extensions:*gc-verbose* onoff))
  193. #+(or lispworks akcl wcl mcl clisp)
  194. (define-mumble-function mumble::gc-messages (onoff)
  195.   onoff)   ; can't figure out if they have a hook or not
  196. #+lucid
  197. (define-mumble-function mumble::gc-messages (onoff)
  198.   (setf lcl:*gc-silence* (not onoff))
  199.   onoff)
  200.  
  201.  
  202. #-(or lucid cmu allegro akcl mcl lispworks wcl clisp)
  203. (missing-mumble-definition mumble::gc-messages)
  204.  
  205.  
  206. (define-mumble-import identity)
  207.